home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / examples / colorsetr.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-05  |  8.4 KB  |  245 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         colorsetr.lsp
  5. ; RCS:          $Header: colorsetr.lsp,v 1.3 91/10/05 15:12:38 mayer Exp $
  6. ; Description:  A useful interface building tool -- use this to create and set
  7. ;        colors on widgets.
  8. ;        NOTE: THIS WON'T WORK W/ MOTIF 1.0 DUE TO USE OF 1.1 FUNCTIONS
  9. ; Author:       Niels Mayer, HPLabs
  10. ; Created:      Mon Oct 29 02:44:55 1990
  11. ; Modified:     Sat Oct  5 15:12:25 1991 (Niels Mayer) mayer@hplnpm
  12. ; Language:     Lisp
  13. ; Package:      N/A
  14. ; Status:       X11r5 contrib tape release
  15. ;
  16. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  17. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  18. ;
  19. ; Permission to use, copy, modify, distribute, and sell this software and its
  20. ; documentation for any purpose is hereby granted without fee, provided that
  21. ; the above copyright notice appear in all copies and that both that
  22. ; copyright notice and this permission notice appear in supporting
  23. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  24. ; used in advertising or publicity pertaining to distribution of the software
  25. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  26. ; makes no representations about the suitability of this software for any
  27. ; purpose.  It is provided "as is" without express or implied warranty.
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29.  
  30. (let (
  31.       toplevel_w
  32.       rc_w apply_pb_w color_label_w
  33.       r_la_w r_scale_w
  34.       g_la_w g_scale_w
  35.       b_la_w b_scale_w
  36.       (background_color (aref (X_ALLOC_N_COLOR_CELLS_NO_PLANES 1) 0))
  37.       color_array
  38.       )
  39.  
  40.   (setq toplevel_w
  41.     (send TOP_LEVEL_SHELL_WIDGET_CLASS :new "colorsetr"
  42.           :XMN_TITLE "Color Setter"
  43.           :XMN_ICON_NAME "ColorSetr"
  44.           ))
  45.   (setq rc_w
  46.     (send XM_FORM_WIDGET_CLASS :new :managed
  47.           "form" toplevel_w
  48.           ))
  49.   (setq apply_pb_w
  50.     (send XM_PUSH_BUTTON_WIDGET_CLASS :new :managed
  51.           "button_apply" rc_w
  52.           :XMN_LABEL_STRING        "Set Color On Selected Widget"
  53.           :XMN_TOP_ATTACHMENT    :attach_position
  54.           :XMN_BOTTOM_ATTACHMENT    :attach_position
  55.           :XMN_TOP_POSITION        0
  56.           :XMN_BOTTOM_POSITION    13
  57.           :XMN_LEFT_ATTACHMENT    :attach_form
  58.           :XMN_RIGHT_ATTACHMENT    :attach_form
  59.           ))
  60. ;;;(setq take_pb_w
  61. ;;;      (send XM_PUSH_BUTTON_WIDGET_CLASS :new :managed
  62. ;;;        "button_take" rc_w
  63. ;;;        :xmn_label_string "Take Color From Selected Widget"
  64. ;;;        ))
  65.   (setq color_label_w
  66.     (send XM_LABEL_WIDGET_CLASS :new :managed "label_color" rc_w
  67.           :XMN_LABEL_STRING        "Color"
  68.           :XMN_TOP_ATTACHMENT    :attach_position
  69.           :XMN_BOTTOM_ATTACHMENT    :attach_position
  70.           :XMN_TOP_POSITION        13
  71.           :XMN_BOTTOM_POSITION    25
  72.           :XMN_LEFT_ATTACHMENT    :attach_form
  73.           :XMN_RIGHT_ATTACHMENT    :attach_form
  74.           ))
  75.   (setq r_la_w
  76.     (send XM_LABEL_GADGET_CLASS :new :managed "label_red" rc_w
  77.           :XMN_LABEL_STRING        "R:"
  78.           :XMN_TOP_ATTACHMENT    :attach_position
  79.           :XMN_BOTTOM_ATTACHMENT    :attach_position
  80.           :XMN_TOP_POSITION        25
  81.           :XMN_BOTTOM_POSITION    50
  82.           :XMN_LEFT_ATTACHMENT    :attach_form
  83.           ))
  84.   (setq r_scale_w
  85.     (send XM_SCALE_WIDGET_CLASS :new :managed "scale_red" rc_w
  86.           :XMN_SHOW_VALUE        t
  87.           :XMN_ORIENTATION        :horizontal
  88.           :XMN_MAXIMUM        255
  89.           :XMN_MINIMUM        0
  90.           :XMN_TOP_ATTACHMENT    :attach_position
  91.           :XMN_BOTTOM_ATTACHMENT    :attach_position
  92.           :XMN_TOP_POSITION        25
  93.           :XMN_BOTTOM_POSITION    50
  94.           :XMN_LEFT_ATTACHMENT    :attach_widget
  95.           :XMN_LEFT_WIDGET        r_la_w
  96.           :XMN_RIGHT_ATTACHMENT    :attach_form
  97.           ))
  98.   (setq g_la_w
  99.     (send XM_LABEL_GADGET_CLASS :new :managed "label_green" rc_w
  100.           :XMN_LABEL_STRING        "G:"
  101.           :XMN_TOP_ATTACHMENT    :attach_position
  102.           :XMN_BOTTOM_ATTACHMENT    :attach_position
  103.           :XMN_TOP_POSITION        50
  104.           :XMN_BOTTOM_POSITION    75
  105.           :XMN_LEFT_ATTACHMENT    :attach_form
  106.           ))
  107.   (setq g_scale_w
  108.     (send XM_SCALE_WIDGET_CLASS :new :managed "scale_green" rc_w
  109.           :XMN_SHOW_VALUE        t
  110.           :XMN_ORIENTATION        :horizontal
  111.           :XMN_MAXIMUM        255
  112.           :XMN_MINIMUM        0
  113.           :XMN_TOP_ATTACHMENT    :attach_position
  114.           :XMN_BOTTOM_ATTACHMENT    :attach_position
  115.           :XMN_TOP_POSITION        50
  116.           :XMN_BOTTOM_POSITION    75
  117.           :XMN_LEFT_ATTACHMENT    :attach_widget
  118.           :XMN_LEFT_WIDGET        g_la_w
  119.           :XMN_RIGHT_ATTACHMENT    :attach_form
  120.           ))
  121.   (setq b_la_w
  122.     (send XM_LABEL_GADGET_CLASS :new :managed "label_blue" rc_w
  123.           :XMN_LABEL_STRING        "B:"
  124.           :XMN_TOP_ATTACHMENT    :attach_position
  125.           :XMN_BOTTOM_ATTACHMENT    :attach_position
  126.           :XMN_TOP_POSITION        75
  127.           :XMN_BOTTOM_POSITION    100
  128.           :XMN_LEFT_ATTACHMENT    :attach_form
  129.           ))
  130.   (setq b_scale_w
  131.     (send XM_SCALE_WIDGET_CLASS :new :managed "scale_blue" rc_w
  132.           :XMN_SHOW_VALUE        t
  133.           :XMN_ORIENTATION        :horizontal
  134.           :XMN_MAXIMUM        255
  135.           :XMN_MINIMUM        0
  136.           :XMN_TOP_ATTACHMENT    :attach_position
  137.           :XMN_BOTTOM_ATTACHMENT    :attach_position
  138.           :XMN_TOP_POSITION        75
  139.           :XMN_BOTTOM_POSITION    100
  140.           :XMN_LEFT_ATTACHMENT    :attach_widget
  141.           :XMN_LEFT_WIDGET        b_la_w
  142.           :XMN_RIGHT_ATTACHMENT    :attach_form
  143.           ))
  144.  
  145.   (send toplevel_w :realize)
  146.  
  147. ;;;(defvar bg_pixel nil)
  148. ;;;(defvar fg_pixel nil)
  149. ;;;(defvar ts_pixel nil)
  150. ;;;(defvar bs_pixel nil)
  151. ;;;(defvar sel_pixel nil)
  152. ;;;(send take_pb_w :set_callback :XMN_ACTIVATE_CALLBACK '()
  153. ;;;      '(
  154. ;;;    (send (get_moused_widget) :get_values
  155. ;;;          :xmn_top_shadow_color 'ts_pixel
  156. ;;;          :xmn_bottom_shadow_color 'bs_pixel
  157. ;;;          :xmn_foreground 'fg_pixel
  158. ;;;          :xmn_background 'bg_pixel)
  159. ;;;
  160. ;;;    (send color_label_w :set_values
  161. ;;;          :xmn_top_shadow_color ts_pixel
  162. ;;;          :xmn_bottom_shadow_color bs_pixel
  163. ;;;          :xmn_foreground fg_pixel
  164. ;;;          :xmn_background bg_pixel)
  165. ;;;    ))
  166.  
  167.   ;; share same callback code between R, G, and B :XMN_DRAG_CALLBACK...
  168.   (setq apply-sliders-to-color-label
  169.     `(
  170.       (let ((saved-integer-format *INTEGER-FORMAT*)
  171.         )
  172.         (setq *INTEGER-FORMAT* "%02lx")
  173.     
  174.         ;; bug -- should unwind-protect this incase we run out of
  175.         ;; colors -- force *INTEGER-FORMAT* back to original value.
  176.         ;; I'm blowing this off because xlisp2.1c/WINTERP 1.14 has 
  177.         ;; 'special' (dynamically bound) variables.
  178.         (send ,color_label_w :set_values
  179.           :XMN_BACKGROUND
  180.           (x_store_color ,background_color
  181.                  (format nil "#~A~A~A" ;RGB in hexadecimal
  182.                      (send ,r_scale_w :get_value) ;R
  183.                      (send ,g_scale_w :get_value) ;G
  184.                      (send ,b_scale_w :get_value)))    ;B
  185.           )
  186.  
  187.         (setq *INTEGER-FORMAT* saved-integer-format)
  188.         )))
  189.  
  190.   ;; set up drag callbacks so that we can se result of color immediately
  191.   ;; we also need to set up value changed callbacks below...
  192.   (send r_scale_w :set_callback :XMN_DRAG_CALLBACK '()
  193.     apply-sliders-to-color-label
  194.     )
  195.   (send g_scale_w :set_callback :XMN_DRAG_CALLBACK '()
  196.     apply-sliders-to-color-label
  197.     )
  198.   (send b_scale_w :set_callback :XMN_DRAG_CALLBACK '()
  199.     apply-sliders-to-color-label
  200.     )
  201.  
  202.   ;; value changed callbacks are needed because colors won't change if you only
  203.   ;; have drag callbacks and you move the slider by means other than dragging.
  204.   (send r_scale_w :set_callback :XMN_VALUE_CHANGED_CALLBACK '()
  205.     apply-sliders-to-color-label
  206.     )
  207.   (send g_scale_w :set_callback :XMN_VALUE_CHANGED_CALLBACK '()
  208.     apply-sliders-to-color-label
  209.     )
  210.   (send b_scale_w :set_callback :XMN_VALUE_CHANGED_CALLBACK '()
  211.     apply-sliders-to-color-label
  212.     )
  213.  
  214.   (send apply_pb_w :set_callback :XMN_ACTIVATE_CALLBACK '()
  215.     '(
  216.       (let ((saved-integer-format *INTEGER-FORMAT*)
  217.         )
  218.         (setq *INTEGER-FORMAT* "%02lx") ;hack: print in hex by setting string used by sprintf in format
  219.         (setq color_array
  220.           (XM_GET_COLORS
  221.            (x_store_color background_color
  222.                   (format nil "#~A~A~A"    ;RGB in hexadecimal
  223.                       (send r_scale_w :get_value) ;R
  224.                       (send g_scale_w :get_value) ;G
  225.                       (send b_scale_w :get_value)))    ;B
  226.            ))
  227.         ;; bug -- should unwind-protect this incase we run out of
  228.         ;; colors -- force *INTEGER-FORMAT* back to original value.
  229.         ;; I'm blowing this off because xlisp2.1c/WINTERP 1.14 has 
  230.         ;; 'special' (dynamically bound) variables.
  231.         (send (get_moused_widget) :set_values
  232.           ;; :XMN_BACKGROUND (aref color_array 0)
  233.           :XMN_BACKGROUND        background_color
  234.           :XMN_FOREGROUND        (aref color_array 1)
  235.           :XMN_TOP_SHADOW_COLOR        (aref color_array 2)
  236.           :XMN_BOTTOM_SHADOW_COLOR    (aref color_array 3)
  237.           :XMN_TROUGH_COLOR        (aref color_array 4)
  238.           )
  239.  
  240.         (setq *INTEGER-FORMAT* saved-integer-format)
  241.         )))
  242.  
  243.   (apply 'eval apply-sliders-to-color-label )
  244.   )
  245.